Render the leaflet map once. Note that the render function does not take any dependencies and is thus only run once.
2
Add a marker every time the map is clicked somewhere. Note that the marker is added not to a new map, but to a proxy of the map that is already rendered.
3
Remove a marker that is clicked. Note how the observer is only triggered when a marker is clicked, i.e. when input$map_marker_click is triggered.
7 Exercise session
7.1 Plotly
Exercise 1.1
Add a new tab to the app. Add an output canvas to the UI and a render function to the server function such that the new tab is able to display an interactive plotly widget.
Solution 1.2
In the UI, add a new tabPanel() to the tabsetPanel().
In the server function, add renderPlotly and assign it to the output object.
output$hist <-renderPlotly({})
Complete code (important lines are highlighted)
library(dplyr)library(tidyr)library(shiny)library(plotly)library(leaflet)library(haven)ess <-readRDS("data/ess_trust.rds")ess_geo <-readRDS("data/ess_trust_geo.rds")# UI ----ui <-fluidPage(titlePanel("European Social Survey - round 10"),## Sidebar ----sidebarLayout(sidebarPanel(### select dependent variableselectInput("xvar",label ="Select a dependent variable",choices =c("Trust in country's parliament"="trust_parliament","Trust in the legal system"="trust_legal","Trust in the police"="trust_police","Trust in politicians"="trust_politicians","Trust in political parties"="trust_parties","Trust in the European Parliament"="trust_eu","Trust in the United Nations"="trust_un" ) ),### select a variable ----selectInput("yvar",label ="Select an independent variable",choices =c("Placement on the left-right scale"="left_right","Age"="age","Feeling about household's income"="income_feeling","How often do you use the internet?"="internet_use","How happy are you?"="happiness" ) ),### select a country ----selectizeInput("countries",label ="Filter by country",choices =unique(ess$country),selected ="FR",multiple =TRUE ),### filter values ----sliderInput("range",label ="Set a value range",min =min(ess$trust_parliament, na.rm =TRUE),max =max(ess$trust_parliament, na.rm =TRUE),value =range(ess$trust_parliament, na.rm =TRUE),step =1 ) ),## Main panel ----mainPanel(tabsetPanel(type ="tabs",### Table tab ----tabPanel(title ="Table",div(style ="height: 600px; overflow-y: auto;",tableOutput("table") ) ),### Plot tab ----tabPanel(title ="Plot",plotlyOutput("plot", height =600) ),### Map tab ----tabPanel(title ="Map",leafletOutput("map", height =600) ),### New tab ----tabPanel(title ="Histogram",plotlyOutput("hist", height =600) ) ) ) ))# Server ----server <-function(input, output, session) {# update slider ----observe({ var <-na.omit(ess[[input$xvar]]) is_ordered <-is.ordered(var) var <-as.numeric(var)updateSliderInput(inputId ="range",min =min(var),max =max(var),value =range(var),step =if (is_ordered) 1 ) }) %>%bindEvent(input$xvar)# filter data ---- filtered <-reactive({req(input$countries, cancelOutput =TRUE) xvar <- input$xvar yvar <- input$yvar range <- input$range# select country ess <- ess[ess$country %in% input$countries, ]# select variable ess <- ess[c("idno", "country", xvar, yvar)]# apply range ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ] ess })# render table ---- output$table <-renderTable({filtered() }, height =400)# render plot ---- output$plot <-renderPlotly({ xvar <- input$xvar yvar <- input$yvar plot_data <-filtered() %>%drop_na() %>%mutate(across(where(is.numeric), .fns = as.ordered)) p <-ggplot(plot_data) +aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +geom_violin(fill ="lightblue", show.legend =FALSE) +theme_classic()ggplotly(p) })# render map ---- output$map <-renderLeaflet({ var <- input$xvar ess_geo <- ess_geo[c("country", var)]# create labels with a bold title and a body labels <-sprintf("<strong>%s</strong><br>%s", ess_geo$country, ess_geo[[var]] ) labels <-lapply(labels, HTML)# create a palette for numerics and ordinalsif (is.ordered(ess_geo[[var]])) { pal <-colorFactor("YlOrRd", domain =NULL) } else { pal <-colorNumeric("YlOrRd", domain =NULL) }# construct leaflet canvasleaflet(ess_geo) %>%# add base mapaddTiles() %>%# add choroplethsaddPolygons(fillColor =pal(ess_geo[[var]]),weight =2,opacity =1,color ="white",fillOpacity =0.7,# highlight polygons on hoverhighlightOptions =highlightOptions(weight =2,color ="#666",fillOpacity =0.7,bringToFront =TRUE ),label = labels ) %>%# add a legendaddLegend(position ="bottomleft",pal = pal,values = ess_geo[[var]],opacity =0.7,title = var ) }) output$hist <-renderPlotly({ })}shinyApp(ui = ui, server = server)
Exercise 1.2
In section 3, we implemented a bivariate plot of the ESS data. For this exercise, create a univariate plotly plot of one of the trust variables. In the solution, I will be using a histogram, but this could also be a stacked bar chart, a kernel density curve, etc. The idea is to get a quick overview of the statistical distribution of a trust variable.
You can do this either through plotly’s own grammar (plot_ly()) or by converting a ggplot (ggplotly()). In the solutions, I will be using plotly though.
Note that, due to a bug in plotly, the labels of the ESS dataset have to be removed from the dataset. This can be done either by casting as.numeric on a variable or by zapping labels with haven::zap_labels().
Solution 1.2
The following solution implements a histogram of the trust_parliament variable.
ess <-readRDS("data/ess_trust.rds")plot_ly(ess, x =~as.numeric(trust_parliament)) %>%add_histogram()
Exercise 1.3
Customize the plotly plot according to the following requests:
Change the axis titles to something useful
Decrease the opacity to 70%
Remove the modebar
Increase the gap between histogram bars to 20%.
Change the bar color to green
Tip
Recall that plotly can be customized using the layout, style, and config functions.
To find out about options specific to a plotly histogram, call plotly::schema() and navigate to traces -> histogram.
Plotly can be very confusing and there is no shame in using google!
Solution 1.3
plot_ly(ess) %>%add_histogram(x =~as.numeric(trust_parliament)) %>%# everything that changes the overall theming goes herelayout(xaxis =list(title ="Trust in the national parliament"),yaxis =list(title ="Observations"),bargap =0.2 ) %>%# everything that changes the data- and plot-specific theming goes herestyle(opacity =0.7, marker =list(color ="green")) %>%# everything that changes the interactivity goes hereconfig(displayModeBar =FALSE)
Exercise 1.4
Implement the plot from exercise 1.3 in the Shiny app. Instead of plotting a single static variable, link the histogram to the input selector for the dependent variable (input$xvar) such that choosing a different trust variable updates the histogram.
Solution 1.4
output$hist <-renderPlotly({plot_ly(filtered()) %>%add_histogram(x =as.numeric(ess[input$xvar])) %>%# everything that changes the overall theming goes herelayout(xaxis =list(title ="Trust in the national parliament"),yaxis =list(title ="Observations"),bargap =0.2 ) %>%# everything that changes the data- and plot-specific theming goes herestyle(opacity =0.7, marker =list(color ="green")) %>%# everything that changes the interactivity goes hereconfig(displayModeBar =FALSE)})
Complete code (important lines are highlighted)
library(dplyr)library(tidyr)library(shiny)library(plotly)library(leaflet)library(haven)ess <-readRDS("data/ess_trust.rds")ess_geo <-readRDS("data/ess_trust_geo.rds")# UI ----ui <-fluidPage(titlePanel("European Social Survey - round 10"),## Sidebar ----sidebarLayout(sidebarPanel(### select dependent variableselectInput("xvar",label ="Select a dependent variable",choices =c("Trust in country's parliament"="trust_parliament","Trust in the legal system"="trust_legal","Trust in the police"="trust_police","Trust in politicians"="trust_politicians","Trust in political parties"="trust_parties","Trust in the European Parliament"="trust_eu","Trust in the United Nations"="trust_un" ) ),### select a variable ----selectInput("yvar",label ="Select an independent variable",choices =c("Placement on the left-right scale"="left_right","Age"="age","Feeling about household's income"="income_feeling","How often do you use the internet?"="internet_use","How happy are you?"="happiness" ) ),### select a country ----selectizeInput("countries",label ="Filter by country",choices =unique(ess$country),selected ="FR",multiple =TRUE ),### filter values ----sliderInput("range",label ="Set a value range",min =min(ess$trust_parliament, na.rm =TRUE),max =max(ess$trust_parliament, na.rm =TRUE),value =range(ess$trust_parliament, na.rm =TRUE),step =1 ) ),## Main panel ----mainPanel(tabsetPanel(type ="tabs",### Table tab ----tabPanel(title ="Table",div(style ="height: 600px; overflow-y: auto;",tableOutput("table") ) ),### Plot tab ----tabPanel(title ="Plot",plotlyOutput("plot", height =600) ),### Map tab ----tabPanel(title ="Map",leafletOutput("map", height =600) ),### New tab ----tabPanel(title ="Histogram",plotlyOutput("hist", height =600) ) ) ) ))# Server ----server <-function(input, output, session) {# update slider ----observe({ var <-na.omit(ess[[input$xvar]]) is_ordered <-is.ordered(var) var <-as.numeric(var)updateSliderInput(inputId ="range",min =min(var),max =max(var),value =range(var),step =if (is_ordered) 1 ) }) %>%bindEvent(input$xvar)# filter data ---- filtered <-reactive({req(input$countries, cancelOutput =TRUE) xvar <- input$xvar yvar <- input$yvar range <- input$range# select country ess <- ess[ess$country %in% input$countries, ]# select variable ess <- ess[c("idno", "country", xvar, yvar)]# apply range ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ] ess })# render table ---- output$table <-renderTable({filtered() }, height =400)# render plot ---- output$plot <-renderPlotly({ xvar <- input$xvar yvar <- input$yvar plot_data <-filtered() %>%drop_na() %>%mutate(across(where(is.numeric), .fns = as.ordered)) p <-ggplot(plot_data) +aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +geom_violin(fill ="lightblue", show.legend =FALSE) +theme_classic()ggplotly(p) })# render map ---- output$map <-renderLeaflet({ var <- input$xvar ess_geo <- ess_geo[c("country", var)]# create labels with a bold title and a body labels <-sprintf("<strong>%s</strong><br>%s", ess_geo$country, ess_geo[[var]] ) labels <-lapply(labels, HTML)# create a palette for numerics and ordinalsif (is.ordered(ess_geo[[var]])) { pal <-colorFactor("YlOrRd", domain =NULL) } else { pal <-colorNumeric("YlOrRd", domain =NULL) }# construct leaflet canvasleaflet(ess_geo) %>%# add base mapaddTiles() %>%# add choroplethsaddPolygons(fillColor =pal(ess_geo[[var]]),weight =2,opacity =1,color ="white",fillOpacity =0.7,# highlight polygons on hoverhighlightOptions =highlightOptions(weight =2,color ="#666",fillOpacity =0.7,bringToFront =TRUE ),label = labels ) %>%# add a legendaddLegend(position ="bottomleft",pal = pal,values = ess_geo[[var]],opacity =0.7,title = var ) }) output$hist <-renderPlotly({plot_ly(filtered()) %>%add_histogram(x =as.numeric(ess[[input$xvar]])) %>%# everything that changes the overall theming goes herelayout(xaxis =list(title = input$xvar),yaxis =list(title ="Observations"),bargap =0.2 ) %>%# everything that changes the data- and plot-specific theming goes herestyle(opacity =0.7, marker =list(color ="green")) %>%# everything that changes the interactivity goes hereconfig(displayModeBar =FALSE) })}shinyApp(ui = ui, server = server)
7.2 Leaflet
7.3 Plot events
7.4 Beyond plotly and leaflet
Exercise 4.1
Thinking back to the list of Javascript libraries for interactive plotting in section 2.1, pick one R interface that appeals to you the most. Study its documentation and vignettes to get a basic understanding of the interface.
Exercise 4.2
Add a new tab to the app. Replicate the violin plots from section 3 as boxplots using an R interface of your choice.
Note that not all plotting libraries support violin and boxplots to the same degree.
Example solution 4.2
An example solution with the highcharter package:
Complete code (important lines are highlighted)
library(dplyr)library(tidyr)library(shiny)library(plotly)library(leaflet)library(haven)ess <-readRDS("../../../data/ess_trust.rds")ess_geo <-readRDS("../../../data/ess_trust_geo.rds")# UI ----ui <-fluidPage(titlePanel("European Social Survey - round 10"),## Sidebar ----sidebarLayout(sidebarPanel(### select dependent variableselectInput("xvar",label ="Select a dependent variable",choices =c("Trust in country's parliament"="trust_parliament","Trust in the legal system"="trust_legal","Trust in the police"="trust_police","Trust in politicians"="trust_politicians","Trust in political parties"="trust_parties","Trust in the European Parliament"="trust_eu","Trust in the United Nations"="trust_un" ) ),### select a variable ----selectInput("yvar",label ="Select an independent variable",choices =c("Placement on the left-right scale"="left_right","Age"="age","Feeling about household's income"="income_feeling","How often do you use the internet?"="internet_use","How happy are you?"="happiness" ) ),### select a country ----selectizeInput("countries",label ="Filter by country",choices =unique(ess$country),selected ="FR",multiple =TRUE ),### filter values ----sliderInput("range",label ="Set a value range",min =min(ess$trust_parliament, na.rm =TRUE),max =max(ess$trust_parliament, na.rm =TRUE),value =range(ess$trust_parliament, na.rm =TRUE),step =1 ) ),## Main panel ----mainPanel(tabsetPanel(type ="tabs",### Table tab ----tabPanel(title ="Table",div(style ="height: 600px; overflow-y: auto;",tableOutput("table") ) ),### Plot tab ----tabPanel(title ="Plot",plotlyOutput("plot", height =600) ),### Map tab ----tabPanel(title ="Map",leafletOutput("map", height =600) ),### Highcharts tab ----tabPanel(title ="Highcharts",highchartOutput("highcharts", height =600) ) ) ) ))# Server ----server <-function(input, output, session) {# update slider ----observe({ var <-na.omit(ess[[input$xvar]]) is_ordered <-is.ordered(var) var <-as.numeric(var)updateSliderInput(inputId ="range",min =min(var),max =max(var),value =range(var),step =if (is_ordered) 1 ) }) %>%bindEvent(input$xvar)# filter data ---- filtered <-reactive({req(input$countries, cancelOutput =TRUE) xvar <- input$xvar yvar <- input$yvar range <- input$range# select country ess <- ess[ess$country %in% input$countries, ]# select variable ess <- ess[c("idno", "country", xvar, yvar)]# apply range ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ] ess })# render table ---- output$table <-renderTable({filtered() }, height =400)# render plot ---- output$plot <-renderPlotly({ xvar <- input$xvar yvar <- input$yvar plot_data <-filtered() %>%drop_na() %>%mutate(across(where(is.numeric), .fns = as.ordered)) p <-ggplot(plot_data) +aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +geom_violin(fill ="lightblue", show.legend =FALSE) +theme_classic()ggplotly(p) })# render map ---- output$map <-renderLeaflet({ var <- input$xvar ess_geo <- ess_geo[c("country", var)]# create labels with a bold title and a body labels <-sprintf("<strong>%s</strong><br>%s", ess_geo$country, ess_geo[[var]] ) labels <-lapply(labels, HTML)# create a palette for numerics and ordinalsif (is.ordered(ess_geo[[var]])) { pal <-colorFactor("YlOrRd", domain =NULL) } else { pal <-colorNumeric("YlOrRd", domain =NULL) }# construct leaflet canvasleaflet(ess_geo) %>%# add base mapaddTiles() %>%# add choroplethsaddPolygons(fillColor =pal(ess_geo[[var]]),weight =2,opacity =1,color ="white",fillOpacity =0.7,# highlight polygons on hoverhighlightOptions =highlightOptions(weight =2,color ="#666",fillOpacity =0.7,bringToFront =TRUE ),label = labels ) %>%# add a legendaddLegend(position ="bottomleft",pal = pal,values = ess_geo[[var]],opacity =0.7,title = var ) })# render highcharts output$highcharts <-renderHighchart({ xvar <- input$xvar yvar <- input$yvar ess <-filtered() %>%zap_labels() %>%na.omit() %>%select(all_of(c(xvar, yvar))) %>%setNames(c("x", "y"))highchart() %>%hc_add_series_list(data_to_boxplot( ess, x, y,color ="black",fillColor ="#ADD8E6",showInLegend =FALSE,name = xvar )) %>%hc_yAxis(min =0, max =max(ess$y, na.rm =TRUE),title =list(text = yvar) ) %>%hc_xAxis(type ="category", title =list(text = xvar)) %>%hc_legend(enabled =FALSE) })}shinyApp(ui = ui, server = server)
An example solution with the apexcharter package:
Complete code (important lines are highlighted)
library(dplyr)library(tidyr)library(shiny)library(plotly)library(leaflet)library(haven)ess <-readRDS("../../../data/ess_trust.rds")ess_geo <-readRDS("../../../data/ess_trust_geo.rds")# UI ----ui <-fluidPage(titlePanel("European Social Survey - round 10"),## Sidebar ----sidebarLayout(sidebarPanel(### select dependent variableselectInput("xvar",label ="Select a dependent variable",choices =c("Trust in country's parliament"="trust_parliament","Trust in the legal system"="trust_legal","Trust in the police"="trust_police","Trust in politicians"="trust_politicians","Trust in political parties"="trust_parties","Trust in the European Parliament"="trust_eu","Trust in the United Nations"="trust_un" ) ),### select a variable ----selectInput("yvar",label ="Select an independent variable",choices =c("Placement on the left-right scale"="left_right","Age"="age","Feeling about household's income"="income_feeling","How often do you use the internet?"="internet_use","How happy are you?"="happiness" ) ),### select a country ----selectizeInput("countries",label ="Filter by country",choices =unique(ess$country),selected ="FR",multiple =TRUE ),### filter values ----sliderInput("range",label ="Set a value range",min =min(ess$trust_parliament, na.rm =TRUE),max =max(ess$trust_parliament, na.rm =TRUE),value =range(ess$trust_parliament, na.rm =TRUE),step =1 ) ),## Main panel ----mainPanel(tabsetPanel(type ="tabs",### Table tab ----tabPanel(title ="Table",div(style ="height: 600px; overflow-y: auto;",tableOutput("table") ) ),### Plot tab ----tabPanel(title ="Plot",plotlyOutput("plot", height =600) ),### Map tab ----tabPanel(title ="Map",leafletOutput("map", height =600) ),### Highcharts tab ----tabPanel(title ="Highcharts",apexchartOutput("highcharts", height =600) ) ) ) ))# Server ----server <-function(input, output, session) {# update slider ----observe({ var <-na.omit(ess[[input$xvar]]) is_ordered <-is.ordered(var) var <-as.numeric(var)updateSliderInput(inputId ="range",min =min(var),max =max(var),value =range(var),step =if (is_ordered) 1 ) }) %>%bindEvent(input$xvar)# filter data ---- filtered <-reactive({req(input$countries, cancelOutput =TRUE) xvar <- input$xvar yvar <- input$yvar range <- input$range# select country ess <- ess[ess$country %in% input$countries, ]# select variable ess <- ess[c("idno", "country", xvar, yvar)]# apply range ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ] ess })# render table ---- output$table <-renderTable({filtered() }, height =400)# render plot ---- output$plot <-renderPlotly({ xvar <- input$xvar yvar <- input$yvar plot_data <-filtered() %>%drop_na() %>%mutate(across(where(is.numeric), .fns = as.ordered)) p <-ggplot(plot_data) +aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +geom_violin(fill ="lightblue", show.legend =FALSE) +theme_classic()ggplotly(p) })# render map ---- output$map <-renderLeaflet({ var <- input$xvar ess_geo <- ess_geo[c("country", var)]# create labels with a bold title and a body labels <-sprintf("<strong>%s</strong><br>%s", ess_geo$country, ess_geo[[var]] ) labels <-lapply(labels, HTML)# create a palette for numerics and ordinalsif (is.ordered(ess_geo[[var]])) { pal <-colorFactor("YlOrRd", domain =NULL) } else { pal <-colorNumeric("YlOrRd", domain =NULL) }# construct leaflet canvasleaflet(ess_geo) %>%# add base mapaddTiles() %>%# add choroplethsaddPolygons(fillColor =pal(ess_geo[[var]]),weight =2,opacity =1,color ="white",fillOpacity =0.7,# highlight polygons on hoverhighlightOptions =highlightOptions(weight =2,color ="#666",fillOpacity =0.7,bringToFront =TRUE ),label = labels ) %>%# add a legendaddLegend(position ="bottomleft",pal = pal,values = ess_geo[[var]],opacity =0.7,title = var ) })# render highcharts output$highcharts <-renderApexchart({ xvar <- input$xvar yvar <- input$yvarapex(filtered(), aes(.data[["trust_eu"]], .data[["left_right"]]), "boxplot") %>%ax_plotOptions(boxPlot =boxplot_opts(color.upper ="#ADD8E6", color.lower ="#ADD8E6")) %>%ax_stroke(colors =list("black")) %>%ax_labs(x ="eu_trust", y ="left_right") })}shinyApp(ui = ui, server = server)